Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/PASCAL/0189.ZIP/FILER.PAS

Pascal/Delphi Source File | 1986-02-09 | 37KB | 1,082 lines

(***************************************************************)
(*                                                             *)
(*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
(*                                                             *)
(*        (C) 1985 by  John M. Harlan                          *)
(*                     24000 Telegraph                         *)
(*                     Southfield, MI. 48034                   *)
(*                                                             *)
(*     The FILER GROUP of programs is released on a "FREE      *)
(*     SOFTWARE" basis.  The recipient is free to examine      *)
(*     and use the software with the understanding that if     *)
(*     the FILER GROUP of programs prove to be of use and      *)
(*     value,  a contribution to the author is encouraged.     *)
(*                                                             *)
(*     While reasonable effort has been made to ensure the     *)
(*     reliability of the FILER GROUP of programs, no war-     *)
(*     ranty is given. The recipient uses the programs at      *)
(*     his own risk  and in no event shall the author be       *)
(*     liable for damages arising from their use.              *)
(*                                                             *)
(*                                                             *)
(***************************************************************)


{ Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  editors global search/replace. Original version was 100%
  upper case and very hard to read. }

program filer;
{$C-}                       { make ctrl c and ctrl s inoperative }
{  A DATA BASE PROGRAM WRITTEN IN TURBO PASCAL FOR PC-DOS COMPUTERS  }
{  FILER.PAS VERSION 2.0 }
{  INCLUDE FILES : FILER1.PAS, FILER2.PAS, FILER3.PAS, FILER4.PAS }
{  JUNE 28, 1985  }

label              FLIERSTART;

type
  Range          = array[1..256] of char;
  String60       = string[60];
  NameStr        = string[12];

const
  hilight          : string[3]  = ' ';
  lowlight         : string[3]  = '';

var
  filerecchgd      : boolean;
  condition        : boolean;
  changedate       : boolean;
  abortchar        : boolean;
  recaddedtofile   : boolean;
  fileexists       : boolean;

  ch,ch1,option    : char;
  searchtype       : char;

  filename       : string[6];
  filedate,
  currdate       : string[8];
  sourcename     : string[14];
  ans            : String60;
  target         : String60;
  lasttarget     : String60;
  message        : String60;

  w,x,z, code, count, value, len,
  maxnbrrec, nbrrecused, rcdlen,
  blockingfactor, fieldperrecord,
  datarecord, diskrecord, precbyte,
  diskrecnowinmem, nbrdiskrecused,
  lastrecused, first, posn, incr,
  ascii                                      :    integer;

  numvalue, targetvalue                      :    real;

  labellength, datalen, dataform,
  labelposn, dataposn, row,
  column, fieldnbr                  :    array[1..32] of integer;
  lbl                               :    array[1..384] of char;
  getdata                           :    Range;

  source                            :    file;

{================================================================}
{        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
{================================================================}
function BcdToInt (cha : char) : integer;
begin
  BcdToInt := ord(cha) - trunc(ord(cha)/16)*6;
end;
{================================================================}
{             CHARACTER TO INTEGER FUNCTION                      }
{================================================================}
function ChrToInt(var charray : Range; start, len : integer)  : integer;
var
  code, result : integer;
  workstring   : string[10];
begin
  workstring := '';
  for result := 0 to len-1  do
    begin
      if charray[start + result ] = ' ' then
        workstring := workstring + '0'
      else workstring := workstring + charray[start+result];
    end;
  val(workstring,result,code);
  ChrToInt := result;
end;
{================================================================}
{                   BIG CURSOR PROCEDURE                         }
{================================================================}
procedure CursOn;
var
  result      : record
      ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
      end;
begin
  if Mem[$0000:$0449] = 7 then
      result.cx := $000d
  else
      result.cx := $0007;
  result.ax := $0100;
  Intr($10,result);
end;
{================================================================}
{                   REGULAR VIDEO PROCEDURE                      }
{================================================================}
procedure RegVideo;
begin
  TextColor(yellow);
  TextBackGround(blue);
end;
{================================================================}
{                   REVERSE VIDEO PROCEDURE                      }
{================================================================}
procedure RevVideo;
begin
  TextColor(white);
  TextBackGround(black);
end;
{================================================================}
{           PRINT GETDATA PROCEDURE (TEMPORARY)                  }
{================================================================}
procedure PrtGetData;
var w : integer;
  begin
    GotoXY(1,18);
    for w := 1 to 128 do
    write(getdata[w]);
    writeln;
    read(Kbd,ch);
  end;
{================================================================}
{               GET DATA FROM ARRAY PROCEDURE                    }
{================================================================}
procedure GetDataFromArray(var message : String60);
var w,x :  integer;
begin
  message := '';
  for w := precbyte+dataposn[z] to precbyte+dataposn[z+1]-1 do
    message := message + getdata[w];
  if dataform[z] <> ascii then      { CHANGE TRAILING MINUS SIGN }
    begin                           { TO LEADING MINUS SIGN      }
      x := length(message);
      if message[x] = '-' then
        begin
          delete(message,x,1);
          w := 1;
          while (w<x) and (message[w] = ' ') do
            w := succ(w);
          insert('-',message,w);
        end;
    end;
end;
{================================================================}
{                       Edit PROCEDURE                           }
{================================================================}
procedure Edit(var message : String60);
var
  w           :  integer;
  decptr      :  integer;

begin
  if length(message) > 0 then
    begin
      if dataform[z] = 0 then decptr := datalen[z]-2
      else decptr := datalen[z]-dataform[z]-3;
      while decptr > 1 do
        begin
          if message[decptr-1] <> '-' then
            begin
              if message[decptr-1] in [' ','$'] then
                insert(' ',message,decptr)
              else insert(',',message,decptr);
            end;
          decptr := decptr -3;
        end;
    end; { IF LENGTH BEGIN }
end;
{================================================================}
{               Tide (Edit BACKWARDS) PROCEDURE                  }
{================================================================}
procedure Tide( var message : String60);
var w  :  integer;
begin
  w := length(message);
  while w>0 do
    begin
      if message[w] in [',', '$', '+'] then
        begin
          delete(message,w,1);
          message := ' ' + message;
        end
      else w := w-1;
    end;
end;
{================================================================}
{                         Beep PROCEDURE                         }
{================================================================}
procedure Beep;
begin
  Sound(800);
  Delay(100);
  NoSound;
end;
{================================================================}
{               STRING TO REAL NUMBER PROCEDURE                  }
{================================================================}
procedure StringToReal(var source:String60;var numb:real;var code:integer);
var
  x,w  :  integer;
begin
  w := 1;
  while (w < length(source)+1) and (source[w] = ' ') do
    w := w+1;
  x := w;
  while (w < length(source)+1) and (source[w] <> ' ') do
    w := w+1;
  source := copy(source,x,w-x);
  val( source,numb,code );
  if code <> 0 then Beep;
end;
{================================================================}
{           STORE DATA IN ARRAY GETDATA PROCEDURE                }
{================================================================}
procedure StoreDataInArray;

begin
  first := 1;
  if dataform[z] <> ascii then
    begin                       { RIGHT JUSTIFY NUMBER }
      if length(ans) > 0 then StringToReal(ans,numvalue,code)
        else numvalue := 0;
      str(numvalue:20:8,ans);
      first := pos('.',ans)-datalen[z];
      if dataform[z] <> 0 then first := first + dataform[z] + 1;
      if dataform[z] = ascii then first := 1;
    end;
  FillChar(getdata[precbyte+dataposn[z]],datalen[z],' ');
  Move(ans[first],getdata[precbyte+dataposn[z]],datalen[z]);
end;

{================================================================}
{                  WRITE MESSAGE PROCEDURE                       }
{================================================================}
procedure WriteMessage(var message : String60);
begin
  RevVideo;
  write(message);
  RegVideo;
end;

{================================================================}
{                      KEYIN PROCEDURE                           }
{================================================================}
procedure KeyIn(var message : String60; xpos,ypos,len : integer);

const
  controls       : set of char = [^h..^r,^u..^y,^[..^_,'\'];

var
  w, count       :  integer;
  fldlen         :  integer;
  condition      :  boolean;

begin
  if dataform[z]  = ascii then fldlen := len
  else
    begin
      if dataform[z] = 0 then fldlen := len +((len-1)div 3)
      else fldlen := len+((len-dataform[z]-2)div 3);
      Edit(message);
    end;
  count := 0;
    if length(message)>fldlen then message := copy(message,1,fldlen);
    if dataform[z] <> ascii then Tide(message);
    GotoXY(xpos,ypos);
    WriteMessage(message);
    GotoXY(xpos+count,ypos);
    repeat
      read (Kbd,ch);
      if ch = #27 then
        read (Kbd,ch1)
      else ch1 := ' ';  { INTIIALIZE FOR CHAR WHICH FOLLOWS ESC }

      if abortchar = true then            { THIS CODE IS REQUIRED TO  }
        begin                             { ELIMINATE THE ENTRY OF    }
          abortchar := false;             { UNWANTED CHARACTERS AFTER }
          ch := ^s;                       { A SEARCH IS ABORTED       }
        end;
      case ch of

        ^a  :                                    { LEFT ONE WORD }
            begin
              while(message[count-1] = ' ') and (count>1) do
                count := pred(count);
              while(message[count-1] <> ' ') and (count>1) do
                count := pred(count);
              if count>0 then count := pred(count);
            end;

        ^c  :          { EXIT FIELD MODE, RETURN TO RRECORD MODE }
            begin
              ch  := #27;              { SAME AS F1 FUNCTION KEY }
              ch1 := #59;
            end;

        ^d  :                                { RIGHT 1 CHARACTER }
            begin
              if count < len then count := count +1;
            end;

        ^e  :
            begin
              ch := #27;          { CTRL E = WORDSTAR'S UP 1 LINE }
              ch1 := #64;
            end;

        ^f  :                                     { RIGHT 1 WORD }
            begin
              while(message[count+1] <> ' ') and (count<fldlen) do
                count := succ(count);
              while(message[count+1] = ' ') and (count<fldlen) do
                count := succ(count);
            end;

        ^g  :                    { DELETE CHARACTER UNDER CURSOR }
            begin
              if count>=0 then
                begin
                  message := message + ' ';
                  delete(message,count+1,1);
                  GotoXY(xpos,ypos);
                  WriteMessage(message);
                end;
            end;

        ^i  :                { TAB = MOVE CURSOR 6 CHAR TO RIGHT }
            begin
              count := count + 6;
              if count > len then count := len;
            end;

        ^q  :  count := 0;                  { CURSOR TO LEFT END }

        ^s  :                                 { LEFT 1 CHARACTER }
            begin
              if count >0 then count := count -1;
            end;

        ^t  :                             { DELETE WORD TO RIGHT }
            begin
              w := fldlen - count;
              if message[count+1] = ' ' then
                begin
                 while (message[count+1] = ' ') and (w>0) do
                   begin
                    delete(message,count+1,1);
                    message := message + ' ';
                    w := pred(w);
                  end;
                end
              else
                begin
                  while message[count+1] <> ' ' do
                    begin
                      delete (message,count+1,1);
                      message := message + ' ';
                      w := pred(w);
                    end;
                  while (message[count+1] = ' ') and (w>0) do
                    begin
                      delete (message,count+1,1);
                      message := message + ' ';
                      w := pred(w);
                    end;
                end;
              GotoXY(xpos,ypos);
              WriteMessage(message);
            end;

        ^w  :  count := len-1;               { CURSOR TO RIGHT END }

        ^x  :  ch := ^m;                { WORDSTAR'S DOWN 1 LINE }

        ^y  :                           { WORDSTAR'S CLEAR FIELD }
            begin
              message := '';
              for w := 1 to fldlen do
              message := message + '_';
              GotoXY(xpos,ypos);
              WriteMessage(message);
            end;

        ^z  :                         { CLEAR REMAINDER OF FIELD }
            begin
              for w := count +1 to fldlen+1 do
                  message[w] := '_';
              if length(message)>fldlen then
                message := copy(message,1,fldlen);
              GotoXY(xpos,ypos);
              WriteMessage(message);
            end;

        ^h  :                  { DELETE CHARACTER BEFORE CURSOR }
            begin
              if count>0 then
                begin
                  delete(message,count,1);
                  message := message + ' ';
                  if length(message)>fldlen then
                    message := copy(message,1,fldlen);
                  GotoXY(xpos,ypos);
                  WriteMessage(message);
                  count := count-1;
                end;
            end;


      end; { CASE CH OF }

      if ord(ch) in [32..91,93..126] then    { PROCESS IF ALPHA/NUMERIC }
        begin
          if count < fldlen then
            begin
              count := count +1;
              insert(ch,message,count);
              if length(message)>fldlen then
                message := copy(message,1,fldlen);
              GotoXY(xpos,ypos);
              WriteMessage(message);
            end;
        end;
      GotoXY(xpos+count,ypos);


    until ch in [#27,^j..^m,^r,^v,'\']; { EXIT KEYIN ONLY ON THESE CHAR }


    if dataform[z] <> ascii then Tide(message);  {ELIM COMMAS IF NUMERIC}
    if length(message)>0 then
      begin
        if ch = ^m then ch := message[1];
      end;
    count := fldlen+1;
    condition := false;
    repeat                     { ESTABLISH END OF DATA IN STRING }
      count := count -1;
      if message[count] = '_' then message[count] := ' ';
      if message[count] <> ' ' then condition := true;
      if count = 0 then condition := true;
    until condition = true;
    message := copy(message,1,count);
end;
{================================================================}
{           CALCULATE DISKRECORD & PRECBYTE PROCEDURE            }
{================================================================}
procedure Calculate;
  begin
    diskrecord := trunc((datarecord-1)/blockingfactor)*2+7;
    precbyte := ((datarecord-1) mod blockingfactor)*rcdlen;
  end;
{================================================================}

{================================================================}
{                   GET DATA RECORD PROCEDURE                    }
{================================================================}
procedure GetDataRec;
  begin
    Calculate;
    if diskrecord <> diskrecnowinmem then
      begin
        if filerecchgd = true then
          begin
            if diskrecnowinmem > nbrdiskrecused then
              begin                 { GET NEXT AVAILABLE RECORD }
                Seek(source,nbrdiskrecused+2);
                nbrdiskrecused := diskrecnowinmem;
              end
            else
              begin
                Seek(source,diskrecnowinmem);
              end;
            blockwrite(source,getdata,2);  {SAVE CHANGED DATA}
            filerecchgd := false;
            changedate := true;
          end;

        if diskrecord <= nbrdiskrecused then
          begin
            Seek(source,diskrecord);
            blockread(source,getdata,2);         {  RECORD DATA  }
         end
        else FillChar(getdata[1],256,' '); {SPACES FOR EMPTY REC }

       diskrecnowinmem := diskrecord;
      end;
  end;
{================================================================}
{              PRINT LABEL AND DATA PROCEDURE                    }
{================================================================}
procedure PrintLabDat( z : integer );
var
  w  :  integer;

  begin
    if row[z] <23 then
      begin
        GotoXY(column[z],row[z]);
        for w := labelposn[z] to labelposn[z+1]-1 do
        write (lbl[w]);
        ans := '';
        GetDataFromArray(ans);
        if dataform[z] <> ascii then Edit(ans);
        write(': ' + ans);
      end;
  end;
{================================================================}
{                 DISPLAY ONE RECORD PROCEDURE                   }
{================================================================}
procedure DisplayRec;
begin
  ClrScr;
  for z := 1 to fieldperrecord do
  PrintLabDat(z);
  GotoXY(70,23);
  write('RECORD ',datarecord);
  lastrecused := datarecord;
end;
{================================================================}
{                 FIELD DATA MESSAGE PROCEDURE                   }
{================================================================}
procedure FieldDataMsg;
begin
  GotoXY(1,24);
  write('FIELD DATA Edit MODE     [ USE WORDSTAR Edit ');
  write('COMMANDS ]       F1 = RECORD DONE');
end;
{================================================================}
{                  DELETE RECORD PROCEDURE                       }
{================================================================}
procedure DeleteRec;
  begin
    GotoXY(1,24);
    ClrEol;
    write('OK TO DELETE (Y/N)  ');
    read(Kbd,ch);
    if ch in ['Y','y'] then
      begin
        FillChar(getdata[precbyte+1],rcdlen,' ');
        filerecchgd := true;
        DisplayRec;
      end;
   end;
{================================================================}
{                   ENTER TARGET PROCEDURE                       }
{================================================================}
procedure EnterTarget;
begin
  GotoXY(1,24);
  write('ENTER TARGET : ');
  ClrEol;
  target := '';
  KeyIn(target,16,24,20);
  case ch1 of
    #67,#68 :
          begin
            target := lasttarget;
            GotoXY(16,24);
            RevVideo;
            write(target);
            RegVideo;
          end
    else  { CASE TARGET[1] OF }
          begin
            lasttarget := target;
          end;
    end;  { CASE TARGET[1] OF }
end;
{================================================================}
{                  ENTER FIELD DATA PROCEDURE                    }
{================================================================}
procedure EnterField;
var
  w     :  integer;

begin
  z := 1;
  repeat
    begin
      GetDataFromArray(ans);
      KeyIn(ans,column[z]+labellength[z]+2,row[z],datalen[z]);
      case ch of

        '\'    :
          begin                 { PROCESS BACKSLASH COMMANDS }
            PrintLabDat(z);
            GotoXY(1,23);
            write('FIELD NAME...');
            EnterTarget;
            DelLine;
            z := 0;
            repeat
              z := z + 1;
              ans := '';
              for w := labelposn[z] to labelposn[z+1]-1 do
              ans := ans + lbl[w];
              posn := pos(target,ans);
              if z = fieldperrecord then
                begin
                  if posn = 0 then
                    begin
                      z := 1;
                      posn := 1;
                    end;
                end;
            until posn <> 0;
            GotoXY(1,23);
            write('             ');
            FieldDataMsg;
          end;

        ^r  :                        { ^R = MOVE TO TOP OF FIELD }
          begin
            PrintLabDat(z);
            StoreDataInArray;
            filerecchgd := true;
            z := 1;
          end;

        #27 :
          begin
            case ch1 of

            #59 :              { F1 KEY FOR HOME TO RECORD MODE }
               begin
                 StoreDataInArray;
                 filerecchgd := true;
                 PrintLabDat(z);
                 z := fieldperrecord + 1;          { HOME KEY   }
               end;


            #64 :                      { F6 = UP ARROW FUNCTION }
               begin
                 StoreDataInArray;
                 filerecchgd := true;
                 PrintLabDat(z);
                 if z>1 then z := z-1              { UP ARROW   }
                 else z := fieldperrecord;
               end;

            #60,#66 :         { F2 = LINE FEED, F6 = DOWN ARROW }
               begin
                 StoreDataInArray;
                 filerecchgd := true;
                 PrintLabDat(z);
                 z := z+1;             { LINE FEED & DOWN ARROW }
               end;



            #67,#68  :            { UP [F9] OR DOWN [F10] SEARCH }
               begin
                 w := z;   { SAVE FIELD NUMBER }
                 condition := false;
                 GotoXY(1,23);
                 if ch1 = #68 then
                   begin
                     incr := 1;
                     write('SEARCH UP...');
                     if datarecord = nbrrecused then condition := true;
                   end
                 else
                   begin
                     incr := -1;
                     write('SEARCH DOWN...');
                     if datarecord = 1 then condition := true;
                   end;
                 EnterTarget;
                 if length(target)>0 then
                   begin
                     if dataform[z] <> ascii then
                       begin
                         if (target[1] = '>') or (target[1]='<') then
                           begin
                             searchtype := target[1];
                             target := copy(target,2,length(target)-1);
                           end
                         else searchtype := '=';
                         StringToReal(target,targetvalue,code);
                       end;
                     while condition = false do
                       begin
                         datarecord := datarecord + incr;
                         GetDataRec;
                         GotoXY(70,23);
                         ClrEol;
                         write('RECORD ',datarecord);
                         GetDataFromArray(ans);
                         if dataform[z] <> ascii then
                           begin
                             StringToReal(ans,numvalue,code);
                             case searchtype of
                               '>' : if numvalue>targetvalue then
                                     condition := true;
                               '<' : if numvalue<targetvalue then
                                     condition := true;
                               '=' : if numvalue = targetvalue then
                                     condition := true;
                             end; { CASE SEARCHTYPE }
                           end
                         else
                           begin
                             posn := pos(target,ans);
                             if posn <> 0 then condition := true;
                           end;
                         if datarecord >= nbrrecused then condition := true;
                         if datarecord <= 1 then condition := true;
                         if KeyPressed = true then
                           begin
                            condition := true;
                            abortchar := true;
                           end;
                       end; { WHILE CONDITION... }
                     DisplayRec;
                   end
                 else
                   begin
                     GotoXY(1,23);
                     write('              ');
                   end;
                 FieldDataMsg;
                 z := w;   { RESTORE FIELD NUMBER }
               end;  { CASE OF ^L (UP ARROW) OR ^H (DOWN ARROW) }


            end;  { CASE OF #27 }
          end;  { #27 BEGIN }
      else { CASE CH OF }
          begin
            StoreDataInArray;
            filerecchgd := true;
            PrintLabDat(z);
            z := z+1;
          end;  { ELSE BEGIN }
      end; { CASE CH OF }
    end; {REPEAT BEGIN }
  until z > fieldperrecord;
end;

{===============================================================}
{                       FUNCTION EXIST                          }
{===============================================================}
function Exist(filename : NameStr) : boolean;
var
  fil :  file;
  status : Integer;

begin
  Assign(fil,filename);
  {$I-}
  reset(fil);
  {$I+}
  Exist := (IOResult = 0);
{$I-} Close(fil); status := IOResult; {$I+} (* Required by Turbo 3.x *)
end;                                        (* Added by Doug Stevens *)
{================================================================}
{               IDENTIFY DATA RECORD PROCEDURE                   }
{================================================================}
procedure IdRecord;
begin
  GotoXY(1,24);
  write('ENTER RECORD NUMBER : ');
  read(datarecord);
  if datarecord> nbrrecused then datarecord := nbrrecused;
  if datarecord< 1 then datarecord := 1;
  lastrecused := datarecord+1;        { FORCE DISPLAY AFTER MENU }
  TextMode(c80);
  RegVideo;
  ClrScr;
end;
{================================================================}
{               ADD / ENTER RECORDS PROCEDURE                    }
{================================================================}
procedure AddNewRecord;
begin
  TextMode(c80);
  RegVideo;
  repeat
    nbrrecused := nbrrecused + 1;
    datarecord := nbrrecused;
    GetDataRec;
    DisplayRec;
    GotoXY(1,24);
    write('ADD/ENTER RECORD MODE     [ USE WORDSTAR Edit ');
    write('COMMANDS ]         F1 KEY TO END');
      repeat
        EnterField;
        GotoXY(1,24);
        ClrEol;
        write('DATA RECORD OK? (Y/N/<F1>) ');
        write('    ');
        TextColor(white+blink);
        TextBackGround(red);
        write('<F1> KEY FOR MENU');
        RegVideo;
        GotoXY(28,24);
        read(Kbd,ch);
        if ch = #27 then read(Kbd,ch1) else ch1 := #0;
      until ch <> 'N';
  until ch1 = #59;
  filerecchgd := true;
  recaddedtofile := true;
  lastrecused := datarecord;
  datarecord := 0;                   { A READ OF DATA RECORD 0 }
  GetDataRec;                        { WILL WRITE LAST RECORD  }
 end;
{================================================================}
{             DISPLAY RECORDS TO END PROCEDURE                   }
{================================================================}
procedure DisplayRecords;
begin
  IdRecord;
  repeat
    Calculate;
    GetDataRec;
    if lastrecused <> datarecord then
      begin
        lastrecused := datarecord;
        DisplayRec;
      end;
    GotoXY(1,24);
    write('RETURN TO CONTINUE :         [ F2 TO ENTER DATA ]    ');
    write('      F1 = RETURN TO MENU');
    GotoXY(22,24);
    read(Kbd,ch);
    if ch <> #27 then
      begin
        case ch of
          ^d,^f,^m  :  if datarecord <nbrrecused+1 then { RETURN KEY }
               datarecord := datarecord +1;

          ^h  :  DeleteRec;                             { DELETE KEY }

          ^a,^s  :  if datarecord > 1 then         { F9 = LEFT ARROW }
             datarecord := datarecord -1;

          ^e,^c,^r,^x  :               { WORDSTAR'S UP FIELD COMMAND }
             begin
               FieldDataMsg;
               EnterField;
             end;

        end; { CASE CH OF }
      end
    else
      begin
        read(Kbd,ch1);
        case ch1 of

           #68  :  if datarecord < nbrrecused+1 then  { F10 = RIGHT ARROW }
             datarecord := datarecord +1;

           #59  :  datarecord := nbrrecused +1   ;    { F1 = HOME KEY  }

           #67  :  if datarecord > 1 then            { F9 = LEFT ARROW }
             datarecord := datarecord -1;

           #60,#65,#66  :
             begin                             { LINE FEED }
               FieldDataMsg;
               EnterField;
             end;
        end; { CASE CH OF }
      end;  { ELSE BEGIN  }
  until datarecord > nbrrecused;
end;
{================================================================}
{                  CORRECT RECORD PROCEDURE                      }
{================================================================}
procedure CorrectRecord;
begin
  IdRecord;
  Calculate;
  GetDataRec;
  DisplayRec;
  FieldDataMsg;
  repeat
    EnterField;
    GotoXY(1,24);
    write('DATA RECORD OK? (Y/N) ');
    ClrEol;
    read(Kbd,ch);
    FieldDataMsg;
  until ch <> 'N';
end;

{################################################################}
{                                                                }
{                         MAIN PROGRAM                           }
{                         ============                           }
{################################################################}


begin
FLIERSTART:
  repeat
    TextMode(c40);
    RegVideo;
    ClrScr;
    GotoXY(1,22);
    write('FILER A LA PASCAL');
    GotoXY(1,23);
    write('ENTER SOURCE FILE NAME : ');
    readln(sourcename);
    x := pos('.',sourcename);
    if x <> 0 then sourcename := copy(sourcename,1,x-1);
    sourcename := sourcename + '.DAT';
    fileexists := Exist(sourcename);
  until fileexists = true;
  write('ENTER CURRENT DATE (MM/DD/YY) : ');
  readln( currdate );
  if length(currdate) = 0 then currdate := '  /  /  ';
  Assign( source, sourcename );
  reset( source );
  Seek(source,1);
  blockread( source,getdata,1 );
  blockread( source,lbl,3 );
  filename := 'XXXXXX';
  for x := 1 to 6 do
    filename[x] := getdata[x];
  maxnbrrec := ChrToInt(getdata,7,4);
  nbrrecused := ChrToInt(getdata,11,4);
  rcdlen := ChrToInt(getdata,15,3);
  blockingfactor := ChrToInt(getdata,18,2);
  fieldperrecord := ChrToInt(getdata,20,2);
  filedate := '  /  /  ';
  Move(getdata[22],filedate[1],8);

{================================================================}
{  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
{================================================================}

labelposn[1] := 1;
dataposn[1] := 1;

for x := 1 to fieldperrecord do
  begin
    labellength[x] :=  BcdToInt(getdata[32+x]);
    datalen[x]     :=  BcdToInt(getdata[64+x]);
    dataform[x]    :=  ord(getdata[96+x])-48;
    labelposn[x+1] :=  labelposn[x] + labellength[x];
    dataposn[x+1]  :=  dataposn[x] + datalen[x];
  end;

{================================================================}
{           TRANSLATE REPORT STRUCTURE                           }
{================================================================}

  blockread(source,getdata,1);  { SCREEN INFORMATION }
      { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
      if getdata[1] = 'S' then ascii := 9 else ascii := 15;
  for x := 1 to fieldperrecord do
    begin
      w := x*4+1;
      row[x]       := BcdToInt(getdata[w]);
      column[x] := BcdToInt(getdata[w+1])*10+trunc(BcdToInt(getdata[w+2])/10);
      {FIELDNBR[X]  := BcdToInt(GETDATA[W+3]);} { not implemented }
    end;
{================================================================}
{          INITIALIZE VARIABLES FOR ENTRY INTO FILER             }
{================================================================}
  datarecord := nbrrecused;
  Calculate;
  abortchar := false;         { FLAG TO INDICATE ABORT OF SEARCH }
  changedate := false;  { FLAG TO INDICATE THAT DATA HAS CHANGED }
  diskrecnowinmem := diskrecord -1; { ENSURE DISK READ FIRST TIME}
  filerecchgd := false;      { ENSURE NO WRITE BEFORE FIRST READ }
  lastrecused := 0;               { SET LAST RECORD USED TO ZERO }
  lasttarget := '';     { ENSURE THERE IS A TARGET TO SEARCH FOR }
  nbrdiskrecused := diskrecord;     { ESTABLISH MAX DISK REC NBR }
  recaddedtofile := false; { FLAG TO INDICATE CHANGE IN FILE SIZE}
{================================================================}
{               MASTER MENU                                      }
{================================================================}

  repeat
    TextMode(c40);
    RegVideo;
    ClrScr;
    GotoXY(1,10);
    writeln ('FILER MASTER MENU');
    writeln ('=================');
    writeln ('FILE : ',filename);
    writeln ('LAST CHANGE : ',filedate);
    writeln('ACTIVE RECORDS : ',nbrrecused);
    writeln('LAST RECORD : ',lastrecused);
    writeln;
    writeln ('1. ADD/ENTER RECORDS');
    writeln ('2. DISPLAY RECORDS');
    writeln ('3. CORRECT RECORDS');
    writeln ('4. DELETE RECORD');
    writeln ('5. END FILER PROGRAM');
    writeln;
    write ('ENTER OPTION : ');
    read(option);
        case option of
          '1'  :   AddNewRecord;
          '2'  :   if nbrrecused > 0 then DisplayRecords;
          '3'  :   if nbrrecused > 0 then CorrectRecord;
          '4'  :   if nbrrecused > 0 then
                     begin
                       IdRecord;
                       GetDataRec;
                       DisplayRec;
                       DeleteRec;
                     end;
        end;
  until option in  ['5','9'];
{================================================================}
{                    END PROGRAM                                 }
{================================================================}
  if filerecchgd = true then
    begin                            { WRITE LAST CHANGED RECORD }
      Seek(source,diskrecnowinmem);
      blockwrite(source,getdata,2);
      changedate := true;
    end;

  if recaddedtofile = true then
    begin
      Seek(source,0);                   { UPDATE BASIC/Z BLOCK 0 }
      blockread(source,getdata,1);
      x := (nbrrecused+blockingfactor-1) div blockingfactor +3;
      getdata[3] := chr(x-((x div 256)*256));
      getdata[4] := chr(x div 256);
      Seek(source,0);
      blockwrite(source,getdata,1);
    end;

  Seek(source,1);                   { UPDATE FILER HEADER RECORD }
  blockread(source,getdata,1);
  str(nbrrecused:4,ans);
  Move(ans[1],getdata[11],4);
  if changedate = true then Move(currdate[1],getdata[22],8);
  filedate := currdate;
  Seek(source,1);
  blockwrite(source,getdata,1);
  close(source);
  TextMode(c80);
  if option = '9' then goto FLIERSTART;
  GotoXY(1,22);
  writeln;
  writeln('THANK YOU FOR USING FILER');
  writeln;
  writeln('HAVE A GREAT DAY!');

{================================================================}
end.